(in-package :gwee)

(defclass text (widget data-mixin foreground-mixin)
  ())

(defclass text-area (widget data-mixin background-mixin foreground-mixin margin-mixin offset-mixin)
  ((horizontal-justification :initarg :horizontal-justification :initform :left :accessor text-area-horizontal-justification)
   (vertical-justification :initarg :vertical-justification :initform :top :accessor text-area-vertical-justification)
   (leading :initarg :leading :initform 0 :accessor text-area-leading)
   (wrap-p :initarg :wrap-p :initform t :accessor text-area-wrap-p)
   (styles :initarg :styles :initform nil :accessor text-area-styles))
  (:default-initargs
    :width :minimum
    :height :minimum))

;; backwards compatibility for old padding initargs
(defmethod shared-initialize :after ((obj text-area) slots &key
                                     (left-padding nil left-supplied)
                                     (right-padding nil right-supplied)
                                     (top-padding nil top-supplied)
                                     (bottom-padding nil bottom-supplied))
  (when left-supplied (setf (slot-value obj 'margin-left) left-padding))
  (when right-supplied (setf (slot-value obj 'margin-right) right-padding))
  (when top-supplied (setf (slot-value obj 'margin-top) top-padding))
  (when bottom-supplied (setf (slot-value obj 'margin-bottom) bottom-padding)))

(defgeneric text-data-lines (obj)
  (:documentation "Return a list of each line to display. Do smart
things based on the type of OBJ."))

(defstruct style
  bold italic underline strikethrough foreground background)

(defstruct tag
  index style)

(defstruct line
  text tags)
              
(defmethod text-data-lines ((obj string))
  (loop for i across obj
        with out = (make-string-output-stream :element-type 'character)
        with tag-start = nil
        with tags = nil
        with idx = 0
        if (char= i #\Newline)
          collect (progn
                    (when tag-start
                      (write-char #\^ out)
                      (setf tag-start nil))
                    (prog1
                        (make-line :text (get-output-stream-string out)
                                   :tags tags)
                      (setf idx 0
                            tags nil)))
            into lines
        else if (char= i #\^)
               do (if tag-start
                      (progn
                        (write-char #\^ out)
                        (incf idx)
                        (setf tag-start nil))
                      (setf tag-start t))
        else if tag-start
               do (if (digit-char-p i)
                      (setf tags (nconc tags
                                        (list (make-tag :index idx
                                                        :style (- (char-code i) (char-code #\0)))))
                            tag-start nil)
                      (progn
                        (write-char #\^ out)
                        (write-char i out)
                        (setf tag-start nil)
                        (incf idx 2)))
        else do (write-char i out) (incf idx)
        finally (progn
                  (when tag-start
                    (write-char #\^ out))
                  (let ((text (get-output-stream-string out)))
                    (return
                      (if (plusp (length text))
                          (nconc lines (list (make-line :text text
                                                        :tags tags)))
                          (or lines
                              (list (make-line :text "")))))))))

(defmethod text-data-lines ((obj list))
  (mapcan 'text-data-lines obj))

(defmethod text-data-lines (obj)
  (text-data-lines (prin1-to-string obj)))

;; (defmethod synchronize-dimensions :after ((view text) parent x y width height)
;;   (let* ((txt (text-data-lines (view-data view)))
;;          (maxx (loop for i in txt
;;                   maximize (sdl:get-font-size i
;; 					      :size :w
;; 					      :font (view-font view)))))
;;     ;; fill in some defaults
;;     (when (and (eq (best-width view) :current)
;;                (not (slot-boundp view 'width)))
;;       (setf (view-width view) maxx))
;;     (when (and (eq (best-height view) :current)
;;                (not (slot-boundp view 'height)))
;;       (setf (view-height view) (* (length txt)
;;                                   (sdl:get-font-height :font (view-font view))))))
;;  )

;; (defmethod initialize-instance :after ((view text-area) &key &allow-other-keys)
;;   (let* ((txt (if (and (slot-boundp view 'width)
;;                        (slot-value view 'wrap-p))
;;                   (with-slots (width left-padding right-padding font data) view
;;                       (mapcan (lambda (x) (wrap-text x (- width left-padding right-padding) font))
;;                               (text-data-lines data)))
;;                   (text-data-lines (view-data view))))
;;          (maxx (loop for i in txt
;;                   maximize (sdl:get-font-size i
;; 					      :size :w
;; 					      :font (view-font view)))))
;;     ;; fill in some defaults
;;     (unless (slot-boundp view 'width)
;;       (setf (view-width view) (1+ maxx)))
;;     (unless (slot-boundp view 'height)
;;       (setf (view-height view) (* (length txt)
;;                                   (sdl:get-font-height :font (view-font view))))))
;;  )

(defmethod synchronize-size ((view text-area) (parent view) width height)
  ;; minimum depends on the other dimension.
  (cond
    ((and (eq (best-width view) :minimum)
          (eq (best-height view) :maximum))
     (setf (view-height view) (synchronize-height view parent width height)
           (view-width view) (synchronize-width view parent width (view-height view))))
    ((and (eq (best-width view) :minimum)
          (eq (best-height view) :minimum))
     ;; This only works because synchronize-width-minimum doesn't need
     ;; to use the view's height yet.
     (setf (view-width view) (synchronize-width view parent width height)
           (view-height view) (synchronize-height view parent (view-width view) height)))
    (t
     (setf (view-width view) (synchronize-width view parent width height)
           (view-height view) (synchronize-height view parent (view-width view) height)))))

(defmethod synchronize-width-minimum ((view text-area) (parent view) width height)
  ;; FIXME: for text-areas write the code to determine the minimal
  ;; width that would fit in the view's height.
  (let* ((txt (text-data-lines (view-data view)))
         (maxx (loop for i in txt
                  maximize (sdl:get-font-size (line-text i)
					      :size :w
					      :font (view-font view)))))
    (+ 1 maxx (margin-left view) (margin-right view))))

(defmethod synchronize-height-minimum ((view text-area) (parent view) width height)
  "Calculate the minimum height. This assumes the width slot has already been set."
  (let ((txt (if (text-area-wrap-p view)
                 (with-slots (margin-left margin-right font data) view
                   (mapcan (lambda (x) (wrap-text x (- width margin-left margin-right) font))
                           (text-data-lines data)))
                 (text-data-lines (view-data view)))))
    (+ (* (length txt)
          (+ (sdl:get-font-height :font (view-font view))
             (text-area-leading view)))
       (margin-top view)
       (margin-bottom view))))

(defmethod draw-view ((view text))
  (let ((txt (text-data-lines (format-data view)))
        (fheight (sdl:get-font-height :font (view-font view))))
    (multiple-value-bind (x y) (translate-view-position view)
      (loop
         for i in txt
         ;; center the text within the view
         for cy = (+ y (truncate (- (view-height view) (* (length txt) fheight)) 2)) then (+ cy fheight)
         when (plusp (length (line-text i)))
         do (sdl:draw-string-blended-* (line-text i) x cy
				       :font (view-font view)
				       :color (foreground-color view))))))

(defun wrap-text (line width font &optional (boundary-chars '(#\Space #\Return #\Tab)))
  (labels ((split-by-one-space (string)
             (loop for i = 0 then (1+ j)
                   as j = (position #\Space string :start i)
                   collect (subseq string i j)
                   while j)))
    (let ((paragraph (split-by-one-space (substitute #\Space #\Newline (line-text line))))
          lines
          text-line
          (x 0))
      (loop for i on paragraph for word = (car i) do
        (setf word (format nil "~a~a" word (if (cdr i) " " "")))
        (when (>= (+ x (sdl:get-font-size word :size :w :font font)) width)
          (push (nreverse text-line) lines)
          (setf x 0
                text-line nil))
        (push word text-line)
        (incf x (string-width word font)))
      ;; don't forget the last line
      (push (nreverse text-line) lines)
      (setf lines (nreverse (mapcar (lambda (l) (format nil "~{~a~}" l)) lines)))
      (loop for offset = 0 then (+ offset (length l))
            for l in lines
            collect (make-line :text l
                               :tags (loop for tag in (line-tags line)
                                           when (<= offset (tag-index tag) (+ offset (length l)))
                                             collect (make-tag :index (- (tag-index tag) offset)
                                                               :style (tag-style tag))))))))

(defun sdl-font-style (style)
  (nconc (list :style-normal)
         (when (style-bold style)
           (list :style-bold))
         (when (style-italic style)
           (list :style-italic))
         (when (style-underline style)
           (list :style-underline))))

(defmethod draw-view ((view text-area))
  (with-slots (width height data font wrap-p
               vertical-justification horizontal-justification
               vertical-offset horizontal-offset
               leading
               margin-left margin-right margin-top margin-bottom) view
    (let* ((text (if wrap-p
                     (mapcan (lambda (x) (wrap-text x (- width margin-left margin-right) font))
                             (text-data-lines (format-data view data)))
                     (text-data-lines (format-data view data))))
           (fheight (sdl:get-font-height :font font))
           (start-y (ecase vertical-justification
                      (:top (+ margin-top vertical-offset))
                      (:bottom
                       (- height
                          (* (length text) fheight)
                          (* (1- (length text)) leading)
                          margin-bottom
                          (- vertical-offset)))
                      (:center
                       (+ margin-top
                          vertical-offset
                          (truncate (- height
                                       (* (length text)
                                          fheight)
                                       (* (1- (length text))
                                          leading)
                                       margin-bottom)
                                    2))))))
      (loop for i in text
            with default-style = (make-style :foreground (foreground-color view)
                                             :background nil)
            with style = default-style
            for y from start-y by (+ fheight leading)
            for x = (ecase horizontal-justification
                      (:left (+ margin-left horizontal-offset))
                      (:right
                       (- width
                          (sdl:get-font-size (line-text i) :size :w :font font)
                          margin-right
                          (- horizontal-offset)))
                      (:center
                       (+ margin-left
                          horizontal-offset
                          (truncate (- width
                                       (sdl:get-font-size (line-text i) :size :w :font font)
                                       margin-right)
                                    2))))
            when (plusp (length (line-text i)))
              do
                 ;; draw directly to the main surface. Sure we could cache
                 ;; it, but nah.
                 (multiple-value-bind (vx vy) (translate-view-position view)
                   (loop for start = 0 then (tag-index tag)
                         for tx = (+ vx x) then (+ tx width)
                         for tag in (line-tags i)
                         for text = (subseq (line-text i) start (tag-index tag))
                         for width = (sdl:get-font-size text :size :w :font font)
                         ;; skip it when changing styles without text in between
                         unless (eql start (tag-index tag))
                           do
                              ;;(print `(,sdl-style ,(sdl:get-font-style :font font)))
                              ;;(unless (equal sdl-style (sdl:get-font-style :font font))
                              (when (style-background style)
                                (sdl:draw-box-* tx (+ vy y) width fheight
                                                :color (style-background style)))
                              (sdl:draw-string-blended-*
                               text tx (+ vy y)
                               :color (or (style-foreground style)
                                          (style-foreground default-style))
                               :font font)
                         do
                            (setf style (or (elt (text-area-styles view) (tag-style tag))
                                            default-style))
                            (unless (equal (sdl-font-style style) (sdl:get-font-style :font font))
                              (sdl:set-font-style (sdl-font-style style) :font font))
                         finally
                            ;;(unless (equal sdl-style (sdl:get-font-style :font font))
                            (when (< start (length (line-text i)))
                              (setf text (subseq (line-text i) start)
                                    width (sdl:get-font-size text :size :w :font font))
                              (when (style-background style)
                                (sdl:draw-box-* tx (+ vy y) width fheight
                                                :color (style-background style)))
                              (sdl:draw-string-blended-*
                               text
                               tx (+ vy y)
                               :color (or (style-foreground style)
                                          (style-foreground default-style))
                               :font font))))))
    ;; reset the font style since it might be shared elsewhere.
    (unless (equal (sdl:get-font-style :font font) '(:style-normal))
      (sdl:set-font-style '(:style-normal) :font font))))

;;(defmethod (setf view-data) :after (value (obj text-area))
;;  (view-needs-sync-p (view-parent obj)) t))
